Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/toolbar/tbsrc/file3.bas

BASIC Source File | 1994-10-09 | 29KB | 747 lines

Option Explicit

Type ToolType
    Pos                     As apiRect      ' position on toolbar
    nr                      As Integer      ' nr of tool
    Group                   As Integer      ' group nr of tool
    Visible                 As Integer      ' visible or not
    Enabled                 As Integer      ' enabled or not
    qHelp                   As Integer      ' use qHelp or not
    StatText                As String       ' status text
    MouseText               As String       ' qHelp text
    UseMouse                As Integer      ' us mouse or not
    CopyPicture             As Integer      ' copy picture or not
End Type
Dim mTools()                As ToolType
Dim oTools()                As apiRect'ToolType
Dim ToolSource()            As Control
Dim TooloTarget()           As PictureBox
Dim ToolcTarget()           As PictureBox

Dim ToolGroup               As Integer
Dim ToolLeft                As Integer
Dim qhloaded                As Integer
Dim qhExit                  As Integer
Dim Toolbar                 As PictureBox
Global MDIParent            As Form
Dim qHelp                   As Integer
Dim FTTitle                 As String
Dim FloatingToolbar         As Form
Dim mOver                   As Integer
Dim ToolCnt                 As Integer
Dim lw                      As Integer
Dim ToolMenu                As Control
Dim UseFloatingTool         As Integer
Dim lblstatus               As Label
Dim cReady                  As String
Global ChangeBar            As Integer

Global Const qhNoTool = -1
Global Const qhNotUsed = -2
Global Const qhNoBar = -3
Global Const qhAppExit = -4

Declare Function GetCursor Lib "User" () As Integer

Sub vbQHCopyToolExt (TempTool As ToolType, nr As Integer, Source As Control, Target As PictureBox)
Dim sosm As Integer, toar As Integer, lleft As Integer, rc As Integer
Dim tRect As apiRect
    If ToolGroup < TempTool.Group Then          ' check for new toolgroup
    ToolGroup = TempTool.Group              ' if new toolgroup
    ToolLeft = ToolLeft + 5                 ' space between tools
    End If
    mTools(nr).Pos.left = ToolLeft              ' copy position of tool
    mTools(nr).Pos.top = 3
    mTools(nr).Pos.right = Source.Width
    mTools(nr).Pos.bottom = Source.Height
    mTools(nr).nr = nr                          ' set toolnumber
    mTools(nr).Group = TempTool.Group           ' set toolgroup
    mTools(nr).Visible = TempTool.Visible       ' set toolprops
    mTools(nr).Enabled = TempTool.Enabled
    mTools(nr).qHelp = TempTool.qHelp
    mTools(nr).StatText = TempTool.StatText     ' set stattext
    mTools(nr).MouseText = TempTool.MouseText   ' set tooltext
    mTools(nr).UseMouse = TempTool.UseMouse
    mTools(nr).CopyPicture = TempTool.CopyPicture

    Set ToolSource(nr) = Source                 ' set source
    Set TooloTarget(nr) = Target                ' set target
    If mTools(nr).CopyPicture Then
    Source.Parent.Source.Picture = Source.Picture
    GetWindowRect Source.Parent.Source.hWnd, tRect            ' get source rect

    sosm = Source.Parent.ScaleMode              ' save prop
    Source.Parent.ScaleMode = 3                 ' set new prop
    toar = Target.AutoRedraw                    ' set props
    Target.AutoRedraw = True
                            ' copy tools image
    rc = StretchBlt(Target.hDC, ToolLeft, 3, Source.Parent.Source.Width, Source.Parent.Source.Height, Source.Parent.Source.hDC, 0, 0, tRect.right - tRect.left, tRect.bottom - tRect.top, srcCopy)

    Target.Refresh
    Target.Picture = Target.Image               ' set props
    Target.AutoRedraw = toar
    Source.Parent.ScaleMode = sosm
    End If
    ToolLeft = ToolLeft + Source.Width - 1
End Sub

Sub vbQHelpExt (Target As PictureBox)
Dim i As Integer, tn As Integer
Dim tRect As apiRect, mRect As apiRect
Dim mPos As apiPoint
    If Not mOver Then                       ' if first time in function
    mOver = True
    GetWindowRect Target.hWnd, tRect    ' get toolbar rect
    GetCursorPos mPos                   ' get and calc cursor position
    mPos.X = mPos.X - tRect.left: mPos.Y = mPos.Y - tRect.top
    i = vbQHGetToolNr(Target, mPos)         ' get active tool
    If i = qhNoTool Then                ' invoke help
        i = vbQHToolBarMove(Target)     ' move toolbar
    Else
        i = vbQHGetHelp(Target, i, qHelp)   ' get help
    End If
    If qhExit Then                      ' app closed
        tn = qhAppExit
    Else
        tn = i                          ' toolnr
    End If
vbQHelpBreak:
    vbQHTools tn
    If Not qhExit Then                      ' app closed
        lblstatus = cReady
    End If
    mOver = False
    End If
End Sub

Sub vbQHCalcToolPos (Target As PictureBox)
Dim i As Integer, t As Integer, osm As Integer, oar As Integer, rc As Integer
Dim tRect As apiRect
    If Target.ScaleWidth = lw Then Exit Sub
    lw = Target.ScaleWidth
    osm = Target.ScaleMode
    oar = Target.AutoRedraw
    Target.ScaleMode = 3
    Target.AutoRedraw = True
    Target.Picture = LoadPicture("")
    Target.Cls
    ToolGroup = 0
    ToolLeft = 0
    t = 3'12
    UseFloatingTool = True
    For i = 0 To ToolCnt - 1
    If TooloTarget(i) = Toolbar Then
        If ToolGroup < mTools(i).Group Then         ' check for new toolgroup
        ToolGroup = mTools(i).Group             ' if new toolgroup
        ToolLeft = ToolLeft + 5                 ' space between tools
        End If
        ToolSource(i).Parent.Source.Picture = ToolSource(i).Picture
        GetWindowRect ToolSource(i).Parent.Source.hWnd, tRect     ' get source rect
                            ' copy tools image
        If ToolLeft + ToolSource(i).Width > Target.ScaleWidth - 5 Then
        t = t + ToolSource(i).Height + 5
        ToolLeft = 5
        End If
        oTools(i).left = ToolLeft
        oTools(i).top = t
        oTools(i).right = ToolSource(i).Width
        oTools(i).bottom = ToolSource(i).Height
        rc = StretchBlt(Target.hDC, ToolLeft, t, ToolSource(i).Width, ToolSource(i).Height, ToolSource(i).Parent.Source.hDC, 0, 0, tRect.right - tRect.left, tRect.bottom - tRect.top, srcCopy)
        ToolLeft = ToolLeft + ToolSource(i).Width - 1
        Set ToolcTarget(i) = Target
        If Not mTools(i).Enabled Then
        mTools(i).Enabled = True
        vbQHEnabled i, False
        End If
    End If
    Next i
    Target.ScaleMode = osm
    Target.AutoRedraw = oar
End Sub

Sub vbQHEnabled (MyTool As Integer, Flag As Integer)
Dim oar As Integer
Dim tRect As apiRect
Dim pb As PictureBox
    If mTools(MyTool).CopyPicture And mTools(MyTool).Enabled <> Flag Then ' if Picture is used
    If UseFloatingTool Then         ' if tool is on floating toolbar
        Set pb = ToolcTarget(MyTool)
        tRect = oTools(MyTool)
    Else                            ' if tool is on toolbar
        Set pb = TooloTarget(MyTool)
        tRect.left = mTools(MyTool).Pos.left
        tRect.top = mTools(MyTool).Pos.top
        tRect.right = mTools(MyTool).Pos.right
        tRect.bottom = mTools(MyTool).Pos.bottom
    End If
    If Flag Then                    ' enable tool
        vbQHMakeEnable tRect, pb, MyTool
    Else
        vbQHMakeDisable tRect, pb   ' disable tool
    End If
    If UseFloatingTool And Not ChangeBar Then         ' if tool is on floating toolbar
        Set pb = TooloTarget(MyTool)
        tRect.left = mTools(MyTool).Pos.left
        tRect.top = mTools(MyTool).Pos.top
        tRect.right = mTools(MyTool).Pos.right
        tRect.bottom = mTools(MyTool).Pos.bottom
        If Flag Then                    ' enable tool
        vbQHMakeEnable tRect, pb, MyTool
        Else
        vbQHMakeDisable tRect, pb   ' disable tool
        End If
    End If
    mTools(MyTool).Enabled = Flag
    pb.Picture = pb.Image
    End If
End Sub

Sub vbQHExit (MyForm As Form)
Dim i As Integer
On Error Resume Next
    Select Case MyForm.hWnd
    Case MDIParent.hWnd
        qhExit = True
        For i = 0 To Forms.Count - 1
        If Forms(i).hWnd <> MyForm.hWnd Then Unload Forms(i)
        Next i
    Case FloatingToolbar.hWnd
        Unload ToolSource(0).Parent
        SetChild MyForm.hWnd, MDIParent.hWnd, False
        If Not Toolbar.Visible Then ToolMenu.Checked = False
        UseFloatingTool = False
    End Select
End Sub

Sub vbQHFakeMove (MyForm As Form)
Dim dc As Integer, l As Integer, t As Integer
Dim cRect As apiRect, mRect As apiRect, lRect As apiRect
Dim mPos As apiPoint, oldPos As apiPoint, oPoint As apiPoint
Dim tRect As apiRect, dRect As apiRect
    MP_Alt = Screen.MousePointer                ' save pointer
    zGetInnerRect MDIParent, cRect              ' get mouse rect
    cRect.bottom = cRect.top + MDIParent.ScaleHeight / Screen.TwipsPerPixelY + 1
    If MyForm.MDIChild Then
    ClipCursor cRect                            ' clip mouse region
    End If
    dc = CreateDC("DISPLAY", 0, 0, 0)           ' create dc
    GetCursorPos mPos                           ' get mouse position
    oldPos = mPos
    GetWindowRect MyForm.hWnd, mRect            ' get rect to move
    oPoint.X = mPos.X - mRect.left              ' get x offset
    oPoint.Y = mPos.Y - mRect.top               ' get y offset
    GetWindowRect Toolbar.hWnd, tRect           ' get rect, not to move
    If Toolbar.Align = 1 Then
    lRect.left = tRect.left
    lRect.top = cRect.bottom - tRect.bottom + tRect.top
    lRect.right = tRect.right
    lRect.bottom = cRect.bottom
    Else
    lRect.left = tRect.left
    lRect.top = cRect.top' - tRect.bottom + tRect.top
    lRect.right = tRect.right
    lRect.bottom = cRect.top + tRect.bottom - tRect.top
    dRect = tRect
    tRect = lRect
    lRect = dRect
    End If
    dRect = mRect
    DrawFocusRect dc, dRect                     ' draw rect
    Do
    DoEvents
    Screen.MousePointer = 1                 ' set mousepointer
    oldPos = mPos
    GetCursorPos mPos                       ' get mouse position
    If oldPos.X <> mPos.X Or oldPos.Y <> mPos.Y Then
        DrawFocusRect dc, dRect             ' delete rect, calc new pos
        mRect.left = mRect.left - oldPos.X + mPos.X
        mRect.top = mRect.top - oldPos.Y + mPos.Y
        mRect.right = mRect.right - oldPos.X + mPos.X
        mRect.bottom = mRect.bottom - oldPos.Y + mPos.Y
        If zisPointInRect(mPos, tRect) Then
        dRect = tRect                   ' don't move in this rect
        ElseIf zisPointInRect(mPos, lRect) Then
        dRect = lRect                   ' don't move in this rect
        Else
        dRect = mRect                   ' move rect
        End If
        DrawFocusRect dc, dRect             ' draw rect
    End If
    Loop While GetKeyState(1) < 0               ' while mouse_down
    DrawFocusRect dc, dRect                     ' delete rect
    dc = DeleteDC(dc)                           ' delete dc
    If MyForm.MDIChild Then
    cRect.left = 0: cRect.right = GetSystemMetrics(0)
    cRect.top = 0: cRect.bottom = GetSystemMetrics(1)
    ClipCursor cRect                            ' clip mouse
    End If
    If zisPointInRect(mPos, tRect) Then          ' if mouse over toolbar
    Toolbar.Align = 1
    MakeStatusBar Toolbar
    Toolbar.Visible = True                  ' show toolbar
    Toolbar.Parent.Show
    Unload MyForm                           ' hide form
    ElseIf zisPointInRect(mPos, lRect) Then
    Toolbar.Align = 2
    MakeStatusBar Toolbar
    Toolbar.Visible = True                  ' show toolbar
    Toolbar.Parent.Show
    Unload MyForm                           ' hide form
    Else                                        ' else
    MyForm.Cls                              ' clear form
    If FloatingToolbar.MDIChild Then
        l = mRect.left - MDIParent.Left / Screen.TwipsPerPixelX - GetSystemMetrics(32)
        t = mRect.top - MDIParent.Top / Screen.TwipsPerPixelY - GetSystemMetrics(4) - GetSystemMetrics(15) - GetSystemMetrics(33)
    Else
        l = mPos.X - oPoint.X
        t = mPos.Y - oPoint.Y
    End If
    MyForm.Move l * Screen.TwipsPerPixelX, t * Screen.TwipsPerPixelY        ' move form
    End If
    Screen.MousePointer = MP_Alt                ' restore old mousepointer
End Sub

Private Function vbQHGetHelp (Target As Control, nr As Integer, qHelp As Integer) As Integer
Dim ch As Integer, px As Integer, py As Integer, rc As Integer', qhTool As Integer
Dim MouseState As Integer, fEnter As Integer, mDown As Integer
Dim temp$
Dim mPos As apiPoint, cExt As apiPoint
Dim tRect As apiRect, aRect As apiRect, mRect As apiRect
Dim wPoint As apiPoint, tPoint As apiPoint
Dim StartTime As Single, StopTime As Single
Dim sm As Integer, ds As Integer, dm As Integer, ar As Integer
    GetWindowRect Target.hWnd, tRect        ' Position of Toolbars
    vbQHGetHelp = qhNoTool                  ' Return value
    fEnter = True                           ' just entered function
    Do
NewCursorPos:                               ' Mouse moved
    GetCursorPos mPos                   ' Cursorposition
    DoEvents                            ' relative position of mouse
    If qhExit Then
        If qhloaded Then                ' if QuickHelp is loaded
        qhloaded = False            ' unload it
        Unload wndQHelp
        End If
        Exit Function
    End If
    mPos.X = mPos.X - tRect.left: mPos.Y = mPos.Y - tRect.top
                        ' if mouse is not over tool
    If UseFloatingTool Then
        mRect = oTools(nr)
    Else
        mRect = mTools(nr).Pos
    End If                            'mTools(nr).Pos
    If Not zisPointInRectExt(mPos, mRect) Then
        nr = vbQHGetToolNr(Target, mPos)    ' get new tool
        If nr = qhNoTool Then           ' if there is no new tool
        Exit Do                     ' exit
        Else                            ' else
        If qhloaded Then            ' if QuickHelp is loaded
            qhloaded = False        ' unload it
            Unload wndQHelp
        End If
        WaitZehntel 2               ' wait on further movements
        GoTo NewCursorPos           ' and start again
        End If
    End If
    MouseState = GetKeyState(1)
    If MouseState < 0 Then              ' if mouse_click
        MouseState = True
    Else
        MouseState = False
    End If
    'If qhExit Then Exit Function
    If MouseState Then                  ' if mouse_click
                        ' write status text
        If Len(mTools(nr).StatText) Then lblstatus.Caption = mTools(nr).StatText
                        ' unload qHelp (if loaded)
        If qhloaded Then Unload wndQHelp: qhloaded = False
        sm = Target.ScaleMode           ' save old props
        ds = Target.DrawStyle
        dm = Target.DrawMode
        ar = Target.AutoRedraw
        Target.ScaleMode = 3            ' set new props
        Target.DrawStyle = 0
        Target.DrawMode = 13
        Target.AutoRedraw = False
        Target.Refresh
        Do                              ' wait on mouse_up
        GetCursorPos tPoint             ' get and calc cursor position
        tPoint.X = tPoint.X - tRect.left: tPoint.Y = tPoint.Y - tRect.top
        If zisPointInRectExt(tPoint, mRect) Then
            If Not mDown Then
                        ' perform mouse_click
            rc = BitBlt(Target.hDC, mRect.left + 3, mRect.top + 3, mRect.right - 4, mRect.bottom - 4, Target.hDC, mRect.left + 2, mRect.top + 2, srcCopy)
            Target.Line (mRect.left + 2, mRect.top + 2)-(mRect.left + mRect.right - 2, mRect.top + 2), RGB(192, 192, 192)
            Target.Line (mRect.left + 2, mRect.top + 3)-(mRect.left + 2, mRect.top + mRect.bottom - 2), RGB(192, 192, 192)
            Target.Line (mRect.left + 1, mRect.top + 1)-(mRect.left + 1, mRect.top + mRect.bottom - 2), RGB(128, 128, 128)
            Target.Line (mRect.left + 1, mRect.top + 1)-(mRect.left + mRect.right - 2, mRect.top + 1), RGB(128, 128, 128)
            Target.Line (mRect.left + 2, mRect.top + mRect.bottom - 2)-(mRect.left + mRect.right - 2, mRect.top + mRect.bottom - 2), RGB(192, 192, 192)'RGB(255, 255, 255)
            Target.Line (mRect.left + mRect.right - 2, mRect.top + 2)-(mRect.left + mRect.right - 2, mRect.top + mRect.bottom - 1), RGB(192, 192, 192)'RGB(255, 255, 255)
            mDown = True
            End If
        Else                        ' if mouse not over tool
            If mDown Then Target.Refresh
            mDown = False
        End If
        DoEvents
        If qhExit Then Exit Function' if app closed
        Loop While GetKeyState(1) < 0   ' mouse_up
        Target.Refresh
        Target.ScaleMode = sm           ' restore old props
        Target.DrawStyle = ds
        Target.DrawMode = dm
        Target.AutoRedraw = ar
        If mDown Then                   ' if tool clicked
        vbQHGetHelp = nr            ' return toolnr
        GoTo vbQHGetHelpBreak       ' break
        End If
    Else
        If qHelp Then                       ' if user wants qHelp
        If fEnter Then                  ' if just entered the function
                        ' wait some time
            StartTime = GetTickCount() / 1000
            Do
            StopTime = GetTickCount() / 1000
            DoEvents
                        ' if mouse_click start again
            If GetKeyState(1) < 0 GoTo NewCursorPos
            If qhExit Then Exit Function
            If StartTime + (5 / 10) <= StopTime Then Exit Do
            Loop
            fEnter = False
        End If
        If Not qhloaded Then                ' if qHelp not loaded then
            Load wndQHelp                ' load qHelp
            temp$ = mTools(nr).MouseText    ' text for qHelp
            rc = zvbGetCursorExt(cExt) - 1   ' Cursorheight
            wndQHelp.CurrentX = 2
            wndQHelp.CurrentY = 2
            wndQHelp.Print temp$         ' write text, qhHeight, border
            wndQHelp.Height = (wndQHelp.TextHeight(temp$) + 4) * Screen.TwipsPerPixelX
            wndQHelp.Width = (wndQHelp.TextWidth(temp$) + 4) * Screen.TwipsPerPixelY
            wndQHelp.Line (0, 0)-(wndQHelp.Width / Screen.TwipsPerPixelX - 1, wndQHelp.Height / Screen.TwipsPerPixelY - 1), , B
            GetCursorPos wPoint
                            ' calc position of window
            px = wPoint.X - (wndQHelp.Width / Screen.TwipsPerPixelX) / 2 + cExt.X - 1
            If px < 0 Then                  ' if left pos is negative
            px = 0
            ElseIf (px + wndQHelp.Width / Screen.TwipsPerPixelX) > GetSystemMetrics(0) Then
                            ' if right border is not on screen
            px = GetSystemMetrics(0) - wndQHelp.Width / Screen.TwipsPerPixelX
            End If
            py = (wPoint.Y + cExt.Y - 1)
            If py + wndQHelp.Height / Screen.TwipsPerPixelY > GetSystemMetrics(1) Then
                            ' if lower border is not on screen
            py = wPoint.Y - 2 - wndQHelp.Height / Screen.TwipsPerPixelY
            End If
                            ' set new position of qHelp
            wndQHelp.Move px * Screen.TwipsPerPixelX, Screen.TwipsPerPixelY * py
            GetCursorPos tPoint             ' get and calc cursor position
            tPoint.X = tPoint.X - tRect.left: tPoint.Y = tPoint.Y - tRect.top
            If zisPointInRectExt(tPoint, mRect) Then
                            ' if cursor is over tool
            SetWindowPos wndQHelp.hWnd, -1, 0, 0, 0, 0, &H20 Or &H1 Or &H40 Or &H10 'Or &H8
            Else                            ' if cursor is elsewhere
            Unload wndQHelp
            GoTo NewCursorPos           ' start again
            End If
            qhloaded = True                 ' qHelp loaded successful
        End If  ' Not qhloaded
        End If  ' qHelp
    End If  ' MouseState
    Loop
vbQHGetHelpBreak:
    Unload wndQHelp                              ' unload qHelp
    qhloaded = False
End Function

Private Function vbQHGetToolNr (Target As Control, tPos As apiPoint) As Integer
Dim i As Integer
Dim tRect As apiRect
    vbQHGetToolNr = qhNoTool
    For i = 0 To ToolCnt - 1        ' check every tool for rect and target
    If UseFloatingTool Then
        tRect = oTools(i)
    Else
        tRect = mTools(i).Pos
    End If                         ' mTools(i).Pos
    If zisPointInRectExt(tPos, tRect) Then
        If Target = TooloTarget(i) Then
        If mTools(i).Enabled Then
            vbQHGetToolNr = i   ' return toolnr
        End If
        Exit For
        ElseIf Target = ToolcTarget(i) Then
        If mTools(i).Enabled Then
            vbQHGetToolNr = i   ' return toolnr
        End If
        Exit For
        End If
    End If
    Next i
End Function

Sub vbQHInitTools (cnt As Integer, MyWnd As Form, Target As PictureBox, MyMenu As Control, status As Label, cap As String)
Static Init As Integer
    If Not Init Then
    ToolCnt = cnt
    ToolGroup = 0               ' init groups
    ToolLeft = 0                ' init left
    ReDim mTools(cnt - 1)       ' alloc memory for tools
    ReDim oTools(cnt - 1)
    ReDim ToolSource(cnt - 1)
    ReDim TooloTarget(cnt - 1)
    ReDim ToolcTarget(cnt - 1)
    Set FloatingToolbar = MyWnd
    Set Toolbar = Target                ' set props
    Set MDIParent = Target.Parent
    Set ToolMenu = MyMenu
    Set lblstatus = status
    Target.AutoRedraw = True
    Target.BackColor = BUTTON_FACE
    cReady = cap
    Init = True                 ' init successful
    End If
End Sub

Private Sub vbQHMakeDisable (tRect As apiRect, Target As PictureBox)
Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer
Dim lc As Long, dGrau As Long, hGrau As Long, Weiss As Long
Dim osm As Integer
    dGrau = RGB(128, 128, 128)
    hGrau = RGB(192, 192, 192)
    Weiss = RGB(255, 255, 255)
    tRect.right = tRect.right + tRect.left
    tRect.bottom = tRect.bottom + tRect.top
    osm = Target.ScaleMode
    Target.ScaleMode = 3
    For i = tRect.left + 3 To tRect.right - 3
    l = i: k = 0
    For j = tRect.top + 3 To tRect.bottom - i - 1 + tRect.left
        l = l + 1: lc = Target.Point(l, j)
        Select Case lc
        Case 0
            Target.PSet (l, j), dGrau
            If Target.Point(l + 1, j + 1) <> 0 Then k = True
        Case Else
            If k Then
            If lc <> Weiss Then Target.PSet (l, j), Weiss
            k = False
            Else
            If lc <> hGrau Then
                lc = hGrau: Target.PSet (l, j), lc
            End If
            End If
        End Select
    Next j
    Next i
    k = False
    For i = tRect.top + 2 To tRect.bottom
    'Stop
    l = i: k = 0
    For j = tRect.left + 3 To tRect.right - i - 4 + tRect.top
        l = l + 1
        lc = Target.Point(j, l)
        Select Case lc
        Case 0
            Target.PSet (j, l), dGrau
            If Target.Point(j + 1, l + 1) <> 0 Then k = True
        Case Else
            If k Then
            If lc <> Weiss Then Target.PSet (j, l), Weiss
            k = False
            Else
            If lc <> hGrau Then
                lc = hGrau: Target.PSet (j, l), lc
            End If
            End If
        End Select
    Next j
    Next i
    Target.ScaleMode = osm
End Sub

Private Sub vbQHMakeEnable (tRect As apiRect, pb As PictureBox, ToolNr As Integer)
Dim rc As Integer
    ToolSource(ToolNr).Parent.Source.Picture = ToolSource(ToolNr)
    rc = StretchBlt(pb.hDC, tRect.left, tRect.top, tRect.right, tRect.bottom, ToolSource(ToolNr).Parent.Source.hDC, 0, 0, tRect.right, tRect.bottom, srcCopy)
    If Not UseFloatingTool Then
    Unload ToolSource(ToolNr).Parent
    End If
    pb.Refresh
End Sub

Sub vbQHShowTool ()
    Unload FloatingToolbar      ' unload form
    Toolbar.Visible = True      ' show toolbar
End Sub

Function vbQHToolBarMove (Target As PictureBox) As Integer
Dim i As Integer, g As Integer, h As Integer, t As Integer, l As Integer
Dim wRect As apiRect, tRect As apiRect
Dim mPos As apiPoint, tPos As apiPoint
    vbQHToolBarMove = qhNoTool              ' return value
    If Target = MDIParent.Toolbar Then
    If GetKeyState(1) < 0 Then              ' if mouse_down
        GetWindowRect Target.hWnd, wRect    ' get rect of toolbar
        GetCursorPos mPos                   ' get mouse position
        For i = 0 To ToolCnt - 1            ' on all tools
        If TooloTarget(i) = Target Then ' if this target
                        ' calc width of tools
            tRect.right = tRect.right + mTools(i).Pos.right
            If h < mTools(i).Pos.bottom Then h = mTools(i).Pos.bottom
            If g < mTools(i).Group Then g = mTools(i).Group
        End If
        Next i
        i = False
        tRect.right = tRect.right + g * 5 + 2 * GetSystemMetrics(32)
        tRect.bottom = h + 6 + 2 * GetSystemMetrics(33) + 8
        Do
        DoEvents
        GetCursorPos mPos               ' get mouse position
        If Not zisPointInRect(mPos, wRect) Then      ' mouse not over toolbar
            If zvbQHToolFakeMove(tRect, Target) Then ' move form
            GetCursorPos mPos                   ' get mouse position
            If Not zisPointInRect(mPos, wRect) Then  ' mouse not over toolbar
                Target.Visible = False          ' hide toolbar
                lw = 0
                Load FloatingToolbar            ' load form
                FTTitle = FloatingToolbar.Tag
                If FloatingToolbar.MDIChild Then
                t = mPos.Y - GetSystemMetrics(4) - GetSystemMetrics(15) - Target.Parent.Top / Screen.TwipsPerPixelY - GetSystemMetrics(33)
                l = mPos.X - GetSystemMetrics(32) - Target.Parent.Left / Screen.TwipsPerPixelX
                Else
                t = mPos.Y
                l = mPos.X
                End If
                FloatingToolbar.Move l * Screen.TwipsPerPixelX, t * Screen.TwipsPerPixelY, tRect.right * Screen.TwipsPerPixelX, tRect.bottom * Screen.TwipsPerPixelY
                ChangeBar = True
                FloatingToolbar.Show
                'vbQHCalcToolPos FloatingToolbar ' copy tools and move form
                i = True
            End If
            End If
        End If
        Loop Until GetKeyState(1) >= 0      ' mouse_up
    End If
    End If
End Function

Private Sub vbQHTools (nr As Integer)
    Select Case nr
    Case qhAppExit
        Exit Sub
    Case qhNoBar
        ' nop
    Case qhNotUsed
        ' nop
    Case qhNoTool
        lblstatus.Caption = cReady
    Case Else
        ToolCalled nr, lblstatus
    End Select
End Sub

Sub vbQHUsed (ByVal Flag As Integer)
    qHelp = Flag
End Sub

Private Function zisPointInRect (MyPoint As apiPoint, MyRect As apiRect) As Integer
    If MyPoint.X > MyRect.left And MyPoint.X < MyRect.right And MyPoint.Y > MyRect.top And MyPoint.Y < MyRect.bottom Then zisPointInRect = True
End Function

Private Function zisPointInRectExt (MyPoint As apiPoint, MyRect As apiRect) As Integer
    If MyPoint.X > MyRect.left And MyPoint.X < MyRect.right + MyRect.left And MyPoint.Y > MyRect.top And MyPoint.Y < MyRect.bottom + MyRect.top Then zisPointInRectExt = True
End Function

Private Function zvbGetCursorExt (cPoint As apiPoint) As Integer
Dim hCur As Integer, rc As Integer
Dim hsx As Integer, hsy As Integer
    hCur = GetCursor()                          ' get cursor
    rc = DrawIcon(wndQHelp.hDC, 0, 0, hCur)  ' copy cursor
    wndQHelp.Refresh
    For hsy = GetSystemMetrics(14) To 1 Step -1 ' get x,y ext of cursor
    For hsx = GetSystemMetrics(13) To 1 Step -1
        If wndQHelp.Point(hsx, hsy) = 0 Then
        cPoint.Y = hsy                  ' return x and y
        cPoint.X = hsx
        zvbGetCursorExt = True
        GoTo vbGetCursorExtExit         ' exit sub
        End If
        'vbQHelpForm.PSet (hsx, hsy)
    Next hsx
    Next hsy
vbGetCursorExtExit:
    wndQHelp.Cls                             ' clear form
End Function

Private Function zvbQHToolFakeMove (fRect As apiRect, Target As PictureBox) As Integer
Dim dc As Integer, dx As Integer, dy As Integer, X As Integer, Y As Integer
Dim status As Integer
Dim mPos As apiPoint, oldPos As apiPoint
Dim mRect As apiRect, wRect As apiRect, lRect As apiRect, cRect As apiRect
    MP_Alt = Screen.MousePointer        ' store cursor
    status = True
    GetWindowRect Target.hWnd, wRect
    zGetInnerRect Target.Parent, cRect
    cRect.bottom = cRect.top + Target.Parent.ScaleHeight / Screen.TwipsPerPixelY + 1
    If Target.Align = 1 Then
    lRect.left = wRect.left
    lRect.top = cRect.bottom' - 10' - wRect.bottom + wRect.top
    lRect.right = wRect.right
    lRect.bottom = cRect.bottom + wRect.bottom - wRect.top
    Else
    lRect.left = wRect.left
    lRect.top = cRect.top
    lRect.right = wRect.right
    lRect.bottom = cRect.top + wRect.bottom - wRect.top
    mRect = wRect
    wRect = lRect
    lRect = mRect
    End If
    Screen.MousePointer = 1             ' set cursor
    dc = CreateDC("DISPLAY", 0, 0, 0)   ' create dc
    GetCursorPos mPos                   ' get mouse position
    oldPos = mPos
    mRect.left = fRect.left + mPos.X    ' calc new draw rect
    mRect.top = fRect.top + mPos.Y
    mRect.right = fRect.right + mPos.X
    mRect.bottom = fRect.bottom + mPos.Y
    DrawFocusRect dc, mRect             ' draw rect
    Do
    DoEvents
    Screen.MousePointer = 1         ' set cursor
    oldPos = mPos
    GetCursorPos mPos               ' get mouse position, if changed
    If oldPos.X <> mPos.X Or oldPos.Y <> mPos.Y Then
        DrawFocusRect dc, mRect     ' clear old rect
        If zisPointInRect(mPos, wRect) Then
        mRect = wRect           ' set rect not to move
        ElseIf zisPointInRect(mPos, lRect) Then
        mRect = lRect           ' set rect not to move
        Else
        mRect.left = fRect.left + mPos.X    ' calc new rect
        mRect.top = fRect.top + mPos.Y
        mRect.right = fRect.right + mPos.X
        mRect.bottom = fRect.bottom + mPos.Y
        End If
        DrawFocusRect dc, mRect     ' draw new rect
    End If
    Loop While GetKeyState(1) < 0       ' mouse_up
    DrawFocusRect dc, mRect             ' clear old rect
    dc = DeleteDC(dc)                   ' delete dc
    If zisPointInRect(mPos, wRect) Then
    Target.Align = 1
    status = False
    MakeStatusBar Target
    ElseIf zisPointInRect(mPos, lRect) Then
    Target.Align = 2
    status = False
    MakeStatusBar Target
    End If
    zvbQHToolFakeMove = status
    Screen.MousePointer = MP_Alt        ' restore cursor
End Function